home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / weyl / weyl_lsp.lha / defsystem.lisp < prev    next >
Encoding:
Text File  |  1991-10-21  |  19.2 KB  |  572 lines
  1. ; -*- Mode: LISP; Package: (DEFSYS :use (LISP) :colon-mode :external); Syntax: Common-Lisp; Lowercase: Yes -*-
  2.  
  3. ;;; $Id: defsystem.lisp,v 1.9 1991/10/21 15:28:28 rz Exp $
  4. ;;;
  5. ;;; A portable defsystem facility written in pure Common LISP.
  6. ;;;
  7. ;;; Copyright (c) 1987,1988,1989 Prime Computer, Inc., Natick, MA 01760
  8. ;;;                     All Rights Reserved
  9. ;;;
  10. ;;; Use and copying of this software and preparation of derivative works
  11. ;;; based upon this software are permitted.  Any distribution of this
  12. ;;; software or derivative works must comply with all applicable United
  13. ;;; States export control laws.
  14. ;;;
  15. ;;; This software is made available AS IS, and Prime Computer Inc. makes no
  16. ;;; warranty about the software, its performance or its conformity to any
  17. ;;; specification.
  18. ;;;
  19. ;;; Any person obtaining a copy of this software is requested to send their
  20. ;;; name and post office or electronic mail address to:
  21. ;;;
  22. ;;; dougr@eddie.mit.edu -or- doug@enx.prime.com
  23. ;;;
  24. ;;;
  25.  
  26. #| | $Log: defsystem.lisp,v $
  27. Revision 1.9  1991/10/21  15:28:28  rz
  28. *** empty log message ***
  29.  
  30. Revision 1.8  1991/10/02  17:46:17  rz
  31. *** empty log message ***
  32.  
  33. Revision 1.7  1991/08/27  18:10:05  rz
  34. *** empty log message ***
  35.  
  36. Revision 1.6  1991/08/26  17:58:18  rz
  37. *** empty log message ***
  38.  
  39. Revision 1.5  1991/08/16  00:15:50  rz
  40. *** empty log message ***
  41.  
  42. Revision 1.4  1991/03/06  14:48:48  rz
  43. Really fixed.
  44.  
  45.  
  46. Revision 1.3  91/03/06  14:47:29  rz
  47. Fixed log messages?
  48.  
  49. Revision 2.3  89/02/21  19:55:48  doug
  50. Fixed to not reset *current-system* on recursion through systems.
  51.  
  52. Revision 2.2  87/12/08  10:53:42  doug
  53. Added *current-system*,  *downcase...* 
  54. make load,show,compile-system use *current-system* by default
  55. and set the *current-system*
  56.  
  57. Revision 2.1  87/05/23  14:56:18  doug
  58. Replaced use of concatenate with make-pathname to produce a more portable
  59. pathname generator.  Also added some declarations to quiet compiler error
  60. messages.
  61.  
  62. Revision 2.0  87/05/04  10:52:32  doug
  63. First public version.
  64.  
  65. Revision 1.6  87/05/01  16:23:49  doug
  66. Removed documentation to defsystem.mss,doc,quic
  67. Added :load-after dependencies.
  68. More error checking.  Separate package for defsystem and co.
  69.  
  70. Revision 1.1  87/04/25  13:00:09  doug
  71. Initial Revision
  72.  
  73. ||#
  74.  
  75. ;;; Contains definitions for defsystem, undefsystem, load-system,
  76. ;;; compile-system and show-system.  See defsystem.doc for more
  77. ;;; information.
  78. ;;;
  79.  
  80. (in-package "DEFSYS" :use '(LISP))
  81.  
  82. (export '(defsystem load-system compile-system show-system *suffixes*
  83.        *all-systems* undefsystem *defsystem-version* *defsystem-header*
  84.        *current-system* find-system)
  85.     )
  86.  
  87. ;; Add the feature
  88. (push :defsystem *features*)
  89.  
  90. #+LispWorks
  91. (push :Unix *features*)
  92.  
  93. (defvar *suffixes* nil)
  94. (setf *suffixes*
  95.       #+(and Symbolics 3600)                  '("lisp"  . "bin")
  96.       #+(and Symbolics IMach)                 '("lisp"  . "ibin")
  97.       #+(and dec common vax (not ultrix))     '("LSP"   . "FAS")
  98.       #+(and dec common vax ultrix)           '("lsp"   . "fas")
  99.       #+KCL                                   '("lisp"  . "o")
  100.       #+Xerox                                 '("lisp"  . "dfasl")
  101.       #+(and Lucid MC68000)                   '("lisp"  . "lbin")
  102.       #+(and Lucid Sparc)                     '("lisp"  . "sbin")
  103.       #+(and Lucid MIPS)                      '("lisp"  . "mbin")
  104.       #+(and Lucid VAX VMS)                   '("lisp"  . "vbin")
  105.       #+(and LispWorks Sparc)                 '("lisp"  . "wfasl")
  106.       #+CMU       '("lisp"  . #.(c:backend-fasl-file-type c:*backend*))
  107. ;;;  We don't want to use .CL files, do we?  That's what
  108. ;;;  Allegro says it wants.  We'll use .LISP instead.
  109.       #+Allegro                               '("lisp"  . "fasl")
  110.       #+system::cmu                           '("slisp" . "sfasl")
  111.       #+PRIME                                 '("lisp"  . "pbin")
  112.       #+HP                                    '("l"     . "b")
  113.       #+TI        '("lisp" . #.(string (si::local-binary-file-type)))
  114.       )
  115.  
  116. (defvar *downcase-path-from-module-name*
  117.   #+UNIX T
  118.   #-UNIX NIL)
  119.  
  120. (defvar *defsystem-version*
  121.     "$Revision: 1.9 $")
  122. (defvar *defsystem-header*
  123.     "$Id: defsystem.lisp,v 1.9 1991/10/21 15:28:28 rz Exp $")
  124.  
  125. (defvar *current-system* nil)
  126.  
  127. (defstruct (system (:print-function print-system))
  128.   (name "")
  129.   (host nil) ; NIL or a string naming a host.
  130.   (default-pathname (pathname "") :type pathname)
  131.   (default-package nil :type symbol)
  132.   (needed-systems nil :type list)
  133.   (load-before-compile nil :type list)
  134.   (module-list nil :type list) ;; internal
  135.   (needs-update nil)           ;; internal
  136.   (modules (make-hash-table))) ;; internal
  137.  
  138. (defun print-system (system stream level)
  139.   (declare (ignore level))
  140.   (format stream "#<System ~A>" (system-name system)))
  141.  
  142. (defstruct (module (:print-function print-module))
  143.   (name "")
  144.   (load-before-compile nil)
  145.   (compile-satisfies-load nil)
  146.   (load-after nil)
  147.   (recompile-on nil)
  148.   (pathname nil)
  149.   (package nil)
  150.   (compile-function nil)
  151.   (funcall-after nil)
  152.   (funcall-after-args nil)
  153.   (dtm 0);; internal
  154.   (in-process nil);; internal
  155.   (loaded nil);; internal
  156.   )
  157.  
  158. (defun print-module (module stream level)
  159.   (declare (ignore level))
  160.   (format stream "#<Module ~A>" (module-name module)))
  161.  
  162. (defvar *all-systems* nil)
  163. (defvar *loaded-systems* nil)
  164.  
  165. ;; Argument SYSTEM-NAME is unquoted here!
  166. (defmacro undefsystem (system-name)
  167.   `(setq *all-systems* (remove-if #'(lambda (x)
  168.                       (string-equal (system-name x)
  169.                             ,(string system-name)))
  170.                   *all-systems*)))
  171.  
  172. (defmacro defsystem (system-name options &body modules)
  173.   `(let ((system-construct (append '(:name ,system-name) ',options))
  174.      mod-list)
  175.     (let ((system (apply #'make-system system-construct))
  176.       (system-entry (find-system ',system-name :error-p nil)))
  177.       (when system-entry
  178.     (setq *all-systems* (delete system-entry *all-systems*)))
  179.       (push system *all-systems*)
  180.       (let ((system-mods (system-modules system)))
  181.     (dolist (module ',modules)
  182.       (let ((mod-construct (cons :name module)))
  183.         (if (symbolp module)
  184.         (setq mod-construct (list :name module)))
  185.         (let ((module-structure (apply #'make-module mod-construct)))
  186.           (push (module-name module-structure) mod-list)
  187.           (setf (gethash (module-name module-structure) system-mods)
  188.             module-structure)
  189.           ))
  190.       )
  191.     )
  192.       (setf (system-module-list system) (reverse mod-list))
  193.       )
  194.     ',system-name
  195.     )
  196.   )
  197.  
  198. (defmacro do-default-system (system top-level)
  199.   ;; Set system to *current-system* if NIL and set the
  200.   ;; value of *current-system*
  201.   `(if (and ,system ,top-level)
  202.        (setq *current-system* ,system)
  203.      (unless ,system
  204.        (if *current-system*
  205.        (setq ,system *current-system*)
  206.      (error "Can't default, *current-system* has no value~%"))
  207.        )
  208.      )
  209.   )
  210.  
  211. (defun load-system (&optional system-name 
  212.                   &key reload (include-components T) (top-level T)
  213.                   &aux system *load-verbose*)
  214.   (declare (special *load-verbose*))
  215.   (do-default-system system-name top-level)
  216.   (setq *load-verbose* nil)
  217.   (setq system (find-system system-name))
  218.   ;; Load subsystems
  219.   (when include-components
  220.     (dolist (subsystem (system-needed-systems system))
  221.       (when (or reload (not (member subsystem *loaded-systems*)))
  222.         (format T "~&;;; Loading System ~S~%" subsystem)
  223.         (load-system subsystem :reload reload :top-level NIL
  224.              :include-components include-components))))
  225.   ;; Load modules
  226.   (dolist (module (system-module-list system))
  227.     (let ((module-description (getmod module system)))
  228.       ;; If already loaded then only reload if needed
  229.       (load-if-needed module-description system reload)
  230.       )
  231.     )
  232.   (format T ";;; Done loading system ~S~%" system-name)
  233.   (setf (system-needs-update system) nil)
  234.   (unless (member system-name *loaded-systems*)
  235.     (push system-name *loaded-systems*))
  236.   )
  237.  
  238. (defun compile-load-system (&optional system-name 
  239.                       &key reload recompile
  240.                       (include-components T) (top-level T))
  241.   (do-default-system system-name top-level)
  242.   (compile-system system-name :reload reload :top-level NIL
  243.           :recompile recompile :include-components include-components)
  244.   (load-system system-name :reload reload :top-level NIL
  245.            :include-components include-components)
  246.   ) 
  247.  
  248. (defun compile-system (&optional system-name
  249.                  &key reload recompile (include-components T)
  250.                  (top-level T)
  251.                  &aux system
  252.                  compiled-modules *load-verbose*)
  253.   (declare (special system compiled-modules *load-verbose*))
  254.   (setq *load-verbose* nil)
  255.   (do-default-system system-name top-level)
  256.   (setq system (find-system system-name))
  257.   ;; Recompile included systems
  258.   (when include-components
  259.     (dolist (subsystem (system-needed-systems system))
  260.       (format T "~&;;; Compiling System ~S~%" subsystem)
  261.       (compile-system subsystem
  262.               :recompile recompile :top-level NIL
  263.               :include-components include-components))
  264.     )
  265.   ;; Load Compile subsystem dependencies
  266.   (dolist (subsystem (system-load-before-compile system))
  267.     (when (or reload
  268.               (not (member subsystem *loaded-systems*))
  269.               (system-needs-update subsystem))
  270.       (format T "~&;;; Loading System ~S~%" subsystem)
  271.       (load-system subsystem
  272.            :reload reload :top-level NIL
  273.            :include-components include-components)))
  274.   ;; Compile modules
  275.   (dolist (module (system-module-list system))
  276.     (compile-if-needed module reload recompile)
  277.     )
  278.   nil
  279.   )
  280.  
  281. (defun get-pathname (module system)
  282.   (let ((mdp (machine-dependent-pathname
  283.           (system-default-pathname system)
  284.           (system-host system)))
  285.     mpath sname bname sdtm bdtm)
  286.     (unless (setq mpath (module-pathname module))
  287.       (setq mpath
  288.         (setf (module-pathname module)
  289.           (make-pathname
  290.            #-LispWorks :host #-LispWorks (system-host system)
  291.            :device (pathname-device mdp)
  292.            :directory (pathname-directory mdp)
  293.            :name (mname-to-path (module-name module))))))
  294.     (setq sname (make-pathname
  295.          #-LispWorks :host #-LispWorks (pathname-host mpath)
  296.          :directory (pathname-directory mpath)
  297.          :device (pathname-device mpath)
  298.          :name (pathname-name mpath)
  299.          :type (machine-dependent-lisp-type)))
  300.     (setq bname (make-pathname
  301.          #-LispWorks :host #-LispWorks (pathname-host mpath)
  302.          :directory (pathname-directory mpath)
  303.          :device (pathname-device mpath)
  304.          :name (pathname-name mpath)
  305.          :type (machine-dependent-binary-type)))
  306.     (setq sdtm (and (probe-file sname) (file-write-date sname))
  307.       bdtm (and (probe-file bname) (file-write-date bname)))
  308.     (cond
  309.       ((and sdtm bdtm)            ; Both exist take newer
  310.        (if (> sdtm bdtm)
  311.        sname
  312.        bname))
  313.       (bdtm bname)
  314.       (sdtm sname)
  315.       (T                ; no file around
  316.        (error "Can't find any file for module named ~S"
  317.           (module-name module))))))
  318.  
  319. (defun load-if-needed (module-description system &optional reload)
  320.   (let ((path (get-pathname module-description system))
  321.     (mdp (pathname-directory
  322.           (machine-dependent-pathname
  323.            (system-default-pathname system)
  324.            (system-host system)))))
  325.     (if (and (module-loaded module-description) (not reload))
  326.     (when (< (module-dtm module-description)
  327.          (file-write-date path))
  328.       (do-load system module-description path reload)
  329.       (setf (module-dtm module-description)
  330.         (file-write-date path))
  331.       )
  332.     (progn (do-load system module-description path reload)
  333.            (unless (module-pathname module-description)
  334.          (setf (module-pathname module-description)
  335.                (make-pathname
  336.             #-LispWorks :host #-LispWorks (system-host system)
  337.             :device (pathname-device mdp)
  338.             :directory (pathname-directory mdp)
  339.             :name (mname-to-path (module-name module-description))))
  340.          )
  341.            (setf (module-dtm module-description)
  342.              (file-write-date path))
  343.            (setf (module-loaded module-description) T)))))
  344.  
  345. (defmacro with-package (package &body forms)
  346.   `(if ,package
  347.        (let ((*package* *package*))
  348.      (setf *package* (or (find-package ,package)
  349.                  (make-package ,package)))
  350.      ,@forms)
  351.        (progn ,@forms)))
  352.  
  353. (defun do-load (system module path &optional reload &aux package load-after)
  354.   (when (setq load-after (module-load-after module))
  355.     (when (symbolp load-after) (setq load-after (list load-after)))
  356.     (dolist (m load-after)
  357.       (load-if-needed
  358.        (getmod m system)
  359.        system
  360.        reload
  361.        ))
  362.     )
  363.   (format T "~&;;; Loading file ~S~%" path)
  364.   (setq package (or (module-package module)
  365.                     (system-default-package system)))
  366.   (with-package package
  367.     (load path))
  368.   ;; do funcall after stuff
  369.   (let ((f (module-funcall-after module)))
  370.     (when f (apply f (module-funcall-after-args module)))
  371.     )
  372.   )
  373.  
  374.  
  375. (defun compile-if-needed (module-name &optional reload recompile)
  376.   (declare (special system compiled-modules))
  377.   (let (mdp mpath sname bname module
  378.         sdtm bdtm ddtm ddtms package
  379.         compile-function)
  380.     (setq module (getmod module-name system))
  381.     (setq package (or (module-package module)
  382.               (system-default-package system)))
  383.     ;; Do our dependents
  384.     (if (or (null (module-recompile-on module))
  385.         (module-in-process module))
  386.     (setq ddtms '(0))
  387.     (unwind-protect
  388.         ;; We don't want to recurse infinitely if one module has
  389.         ;; a reciprocal compile relation with another so we set the
  390.         ;; in-process flag to cause this to bottom out.  The
  391.         ;; unwind-protect makes sure it's cleaned up on error cases.
  392.         (progn (setf (module-in-process module) T)
  393.            (dolist (mod (module-recompile-on module))
  394.              (push (compile-if-needed mod) ddtms)
  395.              ))
  396.       (setf (module-in-process module) nil)
  397.       )
  398.     )
  399.     (setq ddtm (apply #'max ddtms))
  400.     (unless (setq mpath (module-pathname module))
  401.       (setq mdp (machine-dependent-pathname
  402.          (system-default-pathname system)
  403.          (system-host system)))
  404.       (setq mpath
  405.         (setf (module-pathname module)
  406.           (make-pathname
  407.            #-LispWorks :host #-LispWorks (system-host system)
  408.            :device (pathname-device mdp)
  409.            :directory (pathname-directory mdp)
  410.            :name (mname-to-path module-name)))))
  411.     (setq sname (make-pathname
  412.          #-LispWorks :host #-LispWorks (pathname-host mpath)
  413.          :directory (pathname-directory mpath)
  414.          :device (pathname-device mpath)
  415.          :name (pathname-name mpath)
  416.          :type (machine-dependent-lisp-type)))
  417.     (setq bname (make-pathname
  418.          #-LispWorks :host #-LispWorks (pathname-host mpath)
  419.          :directory (pathname-directory mpath)
  420.          :device (pathname-device mpath)
  421.          :name (pathname-name mpath)
  422.          :type (machine-dependent-binary-type)))
  423.     (setq sdtm (and (probe-file sname) (file-write-date sname))
  424.       bdtm (and (probe-file bname) (file-write-date bname)))
  425.     (unless bdtm (setq bdtm 0))
  426.     (unless sdtm
  427.       (error "Can't find the source file for ~S~%" module-name))
  428.     (if (and (or (< bdtm sdtm) (< bdtm ddtm)
  429.          (and recompile (not (member module-name compiled-modules))))
  430.          (not (module-in-process module)))
  431.     ;; Recompiling.. load necessary files
  432.     (progn
  433.       (dolist (name (module-recompile-on module))
  434.         (load-if-needed (getmod name system) system reload)
  435.         )
  436.       (dolist (name (module-load-before-compile module))
  437.         (load-if-needed (getmod name system) system reload)
  438.         )
  439.       (format T "~&;;; Compiling ~S..." (module-name module))
  440.       (setq compile-function (module-compile-function module))
  441.       (unless compile-function (setq compile-function #'compile-file))
  442.       (with-package package
  443.         (funcall compile-function sname))
  444.       (when (module-compile-satisfies-load module)
  445.         (setf (module-loaded module) T))
  446.       (format T "~%")
  447.       (push module-name compiled-modules)
  448.       (setf (system-needs-update system) T)
  449.       ;; recompiling produces a new file so...
  450.       (get-universal-time)
  451.       )
  452.     ;; Not recompiling or in process..
  453.     (max bdtm sdtm))))
  454.  
  455. (defun show-system (&optional system-name &aux system)
  456.   (do-default-system system-name T)
  457.   (setq system (find-system system-name))
  458.   (format T "~&;;; System: ~S~%;;;~%" (system-name system))
  459.   (format T ";;; Needed Systems: ~S~%" (system-needed-systems system))
  460.   (format T ";;; Default Package: ~S~%" (system-default-package system))
  461.   (format T ";;; Default Pathname: ~S~%" (system-default-pathname system))
  462.   (format T ";;; Load-before-compile: ~S~%" (system-load-before-compile system))
  463.   (format T ";;; Needs update: ~S~%" (system-needs-update system))
  464.   (format T ";;;~%")
  465.   (dolist (module-name (system-module-list system))
  466.     (let ((module (getmod module-name  system)))
  467.       (format T ";;; Module: ~S  Package: ~S  Loaded: ~S  Compile-satisfies-load: ~S~%"
  468.           module-name (module-package module)
  469.           (module-loaded module) (module-compile-satisfies-load module)
  470.           )
  471.       (format T ";;;    Load-before-compile: ~S ~%"
  472.           (module-load-before-compile module))
  473.       (format T ";;;    Load-after: ~S~%"
  474.           (module-load-after module))
  475.       (format T ";;;    Recompile-on: ~S~%" (module-recompile-on module))
  476.       (format T ";;;    Pathname: ~S~%" (module-pathname module))
  477.       )
  478.     )
  479.   (format T ";;; ---------------------------------")
  480.   )
  481.  
  482. (defun getmod (m s &aux md)
  483.   (setq md (gethash m (system-modules s)))
  484.   (if md
  485.       md
  486.     (error "Module ~S not present in System ~S~%"
  487.        m s)
  488.     )
  489.   )
  490.  
  491. (defun mname-to-path (module)
  492.   ;; Convert module to entryname
  493.   ;; Under UNIX downcase by default
  494.   (if *downcase-path-from-module-name*
  495.       (string-downcase (string module))
  496.     (string module)
  497.     )
  498.   )
  499.  
  500. (defvar *system-registry* "/fsys/nori/b/tmc-hacks/Registry/")
  501.  
  502. ;;; Added key argument ERROR-P to allow using find-system for seeing
  503. ;;; whether a system is defined yet (rick 7-20-89)
  504. ;;; Added use of a global system registry (rz 4-13-90)
  505. (defun find-system (system-name &key (error-p t))
  506.   (flet ((find-system-try ()
  507.        (find (string system-name) *all-systems*
  508.          :test #'(lambda (x y)
  509.                (string-equal x (system-name y))))))
  510.     (let ((system-entry (find-system-try))
  511.       system-file)
  512.       (unless (and *system-registry* (probe-file *system-registry*))
  513.     (setq *system-registry* nil))
  514.       (when (and (null system-entry)
  515.          *system-registry*
  516.          (probe-file (setq system-file
  517.                    (concatenate *system-registry*
  518.                         (string system-name)
  519.                         ".system"))))
  520.     (load system-file)
  521.     (setq system-entry (find-system-try)))
  522.       (and (null system-entry)  error-p 
  523.        (error "No such system description loaded.  System ~S"
  524.           system-name))
  525.       system-entry)))
  526.  
  527.  
  528. ;;;
  529. ;;; When parsing Unix pathname strings on Symbolics machines,
  530. ;;; the host name must be explicitly included in the string.
  531. ;;; Otherwise the "/"s in the string will not be treated as
  532. ;;; they should be (a "/" is just another character in a 
  533. ;;; Symbolics file name)
  534. ;;;
  535. ;;; PATHNAME must be a string or a pathname.
  536. ;;; HOST must be NIL or a string.
  537. ;;;
  538. ;;; On Lisps running under Unix, this function just
  539. ;;; returns PATHNAME.
  540. ;;;
  541. ;;; On Symbolics machines -
  542. ;;;
  543. ;;; If PATHNAME is a pathname we leave it alone (i.e.
  544. ;;; ignore HOST) and return PATHNAME.
  545. ;;;
  546. ;;; If PATHNAME is a string, HOST and PATHNAME are
  547. ;;; combined to form a string containing the host spec.
  548. ;;; and that string is returned.
  549. ;;;
  550. (defun machine-dependent-pathname (pathname host)
  551.   #-Genera (declare (ignore host))
  552.   #-Genera pathname
  553.   #+Genera
  554.   (if (pathnamep pathname)
  555.       pathname
  556.       (concatenate 'string host ":" pathname)))
  557.  
  558. ;;;
  559. ;;; Using (make-pathname ... :type "lisp") doesn't
  560. ;;; results in a pathname like #Pxxx.LISP instead
  561. ;;; of #Pxxx.lisp.  Using
  562. ;;; (make-pathname ... :type :lisp) does what we want.
  563. ;;;
  564. (defun machine-dependent-lisp-type ()
  565.   #-Genera (car *suffixes*)
  566.   #+Genera (intern (string-upcase (car *suffixes*)) 'keyword))
  567.  
  568. ;;; Same as above 
  569. (defun machine-dependent-binary-type ()
  570.   #-Genera (cdr *suffixes*)
  571.   #+Genera (intern (string-upcase (cdr *suffixes*)) 'keyword))
  572.